home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGNG_C / TPTC17GS.LZH / TPCSYM.INC < prev    next >
Text File  |  1988-04-12  |  11KB  |  423 lines
  1.  
  2. (*
  3.  * TPTC - Turbo Pascal to C translator
  4.  *
  5.  * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
  6.  *
  7.  *)
  8.  
  9. const
  10.    previd:  string40 = '?';
  11.  
  12.    
  13.    
  14. (********************************************************************)
  15. function findsym( table: symptr;
  16.                   id:    string40): symptr;
  17.    {locate a symbol in a specified symbol table.  returns pointer to
  18.     the entry if found, otherwise nil is returned}
  19. var
  20.    sym: symptr;
  21.  
  22. begin
  23.    stoupper(id);
  24.    sym := table;
  25.  
  26.    while true do
  27.    begin
  28.  
  29. (*
  30.  *    while (sym <> nil) and
  31.  *          ((length(sym^.id) <> length(id)) or
  32.  *           (sym^.id[1] <> id[1])) do
  33.  *       sym := sym^.next;
  34.  *)
  35.       Inline(
  36.         $C4/$7E/$CF/       {   les di,[bp-$31]}      {es:di=sym^}
  37.         $8B/$4E/$D3/       {   mov cx,[bp-$2d]}      {cl=id[0], ch=id[1]}
  38.                            {loop:}
  39.         $8C/$C0/           {   mov ax,es}            {sym=0?}
  40.         $09/$F8/           {   or ax,di}
  41.         $74/$0C/           {   jz exit}
  42.         $26/$3B/$4D/$05/   {   es: cmp cx,[di+5]}    {length and [1] ==?}
  43.         $74/$06/           {   jz exit}
  44.         $26/$C4/$7D/$5F/   {   es: les di,[di+$5f]}  {sym=sym^.next}
  45.         $EB/$EE/           {   jmp loop}
  46.                            {exit:}
  47.         $89/$7E/$CF/       {   mov [bp-$31],di}      {update sym}
  48.         $8C/$46/$D1);      {   mov [bp-$2f],es}
  49.  
  50.       if (sym = nil) or
  51.          (sym^.id = id) then
  52.       begin
  53.          findsym := sym;
  54.          exit;
  55.       end;
  56.  
  57.       sym := sym^.next;
  58.    end;
  59.  
  60.    findsym := nil;   {symbol not found}
  61. end;
  62.  
  63.  
  64. (********************************************************************)
  65. function locatesym(id:    string40): symptr;
  66.    {locate a symbol in either the local or the global symbol table.
  67.     returns the symbol table entry pointer, if found.  returns
  68.     nil when not in either table}
  69. var
  70.    sym: symptr;
  71. const
  72.    prevsym: symptr = nil;
  73.  
  74. begin
  75.    stoupper(id);
  76.    if id[1] = '^' then
  77.       delete(id,1,1);
  78.       
  79.    {speed hack - don't search if same ident used twice}
  80.    if length(previd) = length(id) then
  81.    if previd = id then
  82.    begin
  83.       locatesym := prevsym;
  84.       exit;
  85.    end;
  86.  
  87.    sym := findsym(locals,id);
  88.    if sym = nil then
  89.       sym := findsym(globals,id);
  90.  
  91.    previd := id;
  92.    prevsym := sym;
  93.    locatesym := sym;
  94. end;
  95.  
  96.  
  97. (********************************************************************)
  98. procedure addsym( var table: symptr;
  99.                   id:        string40;
  100.                   symtype:   symtypes;
  101.                   parcount:  integer;
  102.                   varmap:    integer;
  103.                   lim:       integer;
  104.                   base:      integer;
  105.                   parent:    symptr;
  106.                   dup_ok:    boolean);
  107.    {add a symbol to a specific symbol table.  duplicates hide prior entries.
  108.     new symbol pointed to by cursym}
  109.  
  110. begin
  111.    if maxavail-300 < sizeof(cursym^) then
  112.    begin
  113.       ltok := id;
  114.       fatal('Out of memory');
  115.    end;
  116.  
  117.    if (not dup_ok) and (not in_interface) then
  118.    begin
  119.       cursym := findsym(table,id);
  120.       if cursym <> nil then
  121.       begin
  122.          ltok := id;
  123.          if cursym^.symtype <> ss_builtin then
  124.          if (cursym^.parcount <> parcount) or 
  125.             (cursym^.symtype <> symtype) or (cursym^.limit <> lim) then
  126.             warning('Redeclaration not identical');
  127.          ltok := tok;
  128.       end;
  129.    end;
  130.    
  131.    new(cursym);
  132.    cursym^.next := table;
  133.    table := cursym;
  134.  
  135.    cursym^.repid := decl_prefix + id;
  136.  
  137.    stoupper(id);
  138.    cursym^.id := id;
  139.  
  140.    cursym^.symtype := symtype;
  141.    cursym^.parcount := parcount;
  142.    cursym^.limit := lim;
  143.    cursym^.base := base;
  144.    cursym^.pvar := varmap;
  145.  
  146.    if parent = nil then
  147.       parent := cursym;    {parent=nil causes self reference}
  148.       
  149.    cursym^.parent := parent;
  150.  
  151. (* if debug then
  152. writeln(^M^J'newsym: id=',id,' ty=',typename[symtype],
  153.             ' par=',parent^.id,^M^J);
  154. *)
  155.  
  156.    previd := '?';
  157. end;
  158.  
  159.  
  160. (********************************************************************)
  161. procedure newsym( id:       string40;
  162.                   symtype:  symtypes;
  163.                   parcount: integer;
  164.                   varmap:   integer;
  165.                   lim:      integer;
  166.                   base:     integer;
  167.                   parent:   symptr);
  168.    {enter a new symbol into the current symbol table (local or global)}
  169. begin
  170.    if (unitlevel = 0) or (in_interface) then
  171.       addsym(globals,id,symtype,parcount,varmap,lim,base,parent,false)
  172.    else
  173.       addsym(locals,id,symtype,parcount,varmap,lim,base,parent,true);
  174. end;
  175.  
  176.  
  177.  
  178. (********************************************************************)
  179. procedure addinit(init: string80);
  180.    {add a new initializer to the global initializer table}
  181. begin
  182.    if init_count >= max_init then
  183.    begin
  184.       ltok := init;
  185.       fatal('Too many global initializers');
  186.    end;
  187.  
  188.    inc(init_count);
  189.    init_tab[init_count] := init;
  190. end;
  191.  
  192.  
  193. (********************************************************************)
  194. procedure dumptable(sym: symptr; top: symptr);
  195.    {dump entries from the specified symbol table, stopping where indicated}
  196. var
  197.    info: string40;
  198.    
  199. begin
  200.    if (not dumpsymbols) or (sym = nil) or (sym = top) then
  201.       exit;
  202.  
  203.    putln('/* User symbols:');
  204.    putln(' *    Type                 Class  Base  Limit Pars  Pvar   Identifier');
  205.    putln(' *   -------------------- ------- ---- ------ ---- ------ --------------');
  206.    
  207.    while (sym <> nil) and (sym <> top) and
  208.          ((sym <> builtins) or dumppredef) do
  209.    begin
  210.    
  211.       if sym = builtins then
  212.       begin
  213.          putln(' *');
  214.          putln(' * Predefined symbols:');
  215.          putln(' *    Type                 Class  Base  Limit Pars  Pvar   Identifier');
  216.          putln(' *   -------------------- ------- ---- ------ ---- ------ --------------');
  217.       end;
  218.       
  219.       puts(' *    ');
  220.  
  221.       if sym^.parent <> sym then
  222.          puts(copy(ljust(sym^.parent^.repid,20),1,20))
  223.       else
  224.          puts(ljust(typename[sym^.symtype],20));
  225.  
  226.       case sym^.symtype of
  227.          ss_array:   puts('[]     ');
  228.          ss_pointer: puts('*      ');
  229.          ss_func:    puts('()     ');
  230.          ss_struct:  puts('...    ');
  231.          ss_const:   puts('Const  ');
  232.          ss_subtype: puts('Subtype');
  233.          ss_builtin: puts('Builtin');
  234.          ss_scalar:  puts('Scalar ');
  235.          ss_unit:    puts('Unit   ');
  236.          else        puts('       ');
  237.       end;
  238.  
  239.       write(ofd[unitlevel],
  240.         sym^.base:5,' ',
  241.         sym^.limit:6,' ',
  242.         sym^.parcount:4,' ',
  243.         sym^.pvar:6,'   ',
  244.         sym^.repid);
  245.       putline;
  246.  
  247.       if sym <> nil then
  248.          sym := sym^.next;
  249.    end;
  250.  
  251.    putln(' */');
  252.    putline;
  253. end;
  254.  
  255.  
  256. (********************************************************************)
  257. procedure purgetable( var table: symptr; top: symptr);
  258.    {purge all entries from the specified symbol table}
  259. var
  260.    sym: symptr;
  261.  
  262. begin
  263.    dumptable(table, top);
  264.    
  265.    while (table <> nil) and (table <> top) do
  266.    begin
  267.       sym := table;
  268.       table := table^.next;
  269.       dispose(sym);
  270.    end;
  271.    previd := '?';
  272. end;
  273.  
  274.  
  275. (********************************************************************)
  276. procedure create_unitfile(name: string64; sym, top: symptr);
  277.    {dump symbol table to the specified unit symbol file}
  278. type
  279.    linkptr = ^linkrec;
  280.    linkrec = record
  281.       sym: symptr;
  282.       next: linkptr;
  283.    end;
  284. var
  285.    fd:      text;
  286.    outbuf:  array[1..inbufsiz] of byte;
  287.    rev:     linkptr;
  288.    node:    linkptr;
  289.    
  290. begin
  291.    {build a table of symbols; this is required to preserve the proper
  292.     symbol ordering in the symbol file}
  293.    rev := nil;
  294.    while (sym <> nil) and (sym <> top) do
  295.    begin
  296.       new(node);
  297.       node^.sym := sym;
  298.       node^.next := rev;
  299.       rev := node;
  300.       sym := sym^.next;
  301.    end;
  302.  
  303.    assign(fd,name);
  304. {$I-}
  305.    rewrite(fd);
  306. {$I+}
  307.    if ioresult <> 0 then
  308.    begin
  309.       ltok := name;
  310.       fatal('Can''t create');
  311.    end;
  312.    
  313.    setTextBuf(fd,outbuf);
  314.  
  315.    writeln(fd,symfile_vers);
  316.  
  317.    while rev <> nil do
  318.    begin
  319.       sym := rev^.sym;
  320.       node := rev;
  321.       rev := rev^.next;
  322.       dispose(node);
  323.       
  324.       writeln(fd,sym^.id);
  325.       writeln(fd,sym^.repid);
  326.  
  327.       if sym^.parent = sym then
  328.          writeln(fd,'-')
  329.       else
  330.          writeln(fd,sym^.parent^.id);
  331.  
  332.       writeln(fd,ord(sym^.symtype),' ',
  333.                  sym^.base,' ',
  334.                  sym^.limit,' ',
  335.                  sym^.parcount,' ',
  336.                  sym^.pvar);
  337.       
  338.       inc(objtotal,3);
  339.    end;
  340.  
  341.    close(fd);
  342. end;
  343.  
  344.  
  345. (********************************************************************)
  346. procedure load_unitfile(name: string64; var table: symptr);
  347.    {load symbol table fromthe specified unit symbol file}
  348. var
  349.    fd:      text;
  350.    sym:     symptr;
  351.    stype:   byte;
  352.    inbuf:   array[1..inbufsiz] of byte;
  353.    line:    string;
  354.       
  355. begin
  356.    {enter into initializer table}
  357.    addinit(name + '_init()');
  358.  
  359.    {generate an include for the unit header file}
  360.    puts('#include <'+name+'.UNH>');
  361.    putline;
  362.  
  363.    {read file into the symbol table}
  364.    name := name + '.UNS';
  365.    assign(fd,name);
  366.    {$I-} reset(fd); {$I+}
  367.    if ioresult <> 0 then
  368.    begin
  369.       name := symdir + name;
  370.       assign(fd,name);
  371.       {$I-} reset(fd); {$I+}
  372.    end;
  373.    
  374.    if ioresult <> 0 then
  375.    begin
  376.       ltok := name;
  377.       fatal('Can''t open unit symbol file');
  378.    end;
  379.    
  380.    setTextBuf(fd,inbuf);
  381.  
  382.    readln(fd,line);
  383.    if line <> symfile_vers then
  384.    begin
  385.       ltok := name;
  386.       fatal('Incompatible .UNS format');
  387.    end;
  388.    
  389.    {enter all symbols into symbol table}
  390.    while not eof(fd) do
  391.    begin
  392.       new(sym);
  393.       
  394.       readln(fd,sym^.id);
  395.       readln(fd,sym^.repid);
  396.       readln(fd,line);
  397.       readln(fd,stype,
  398.                 sym^.base,
  399.                 sym^.limit,
  400.                 sym^.parcount,
  401.                 sym^.pvar);
  402.  
  403.       if line[1] = '-' then
  404.          sym^.parent := sym
  405.       else
  406.  
  407.       begin                       {speed hack-search builtins first}
  408.          sym^.parent := findsym(builtins,line);
  409.          if sym^.parent = nil then
  410.             sym^.parent := findsym(table,line);
  411.       end;
  412.  
  413.       sym^.symtype := symtypes(stype);
  414.       sym^.next := table;
  415.       table := sym;
  416.    end;
  417.  
  418.    close(fd);
  419.    previd := '?';
  420. end;
  421.  
  422.  
  423.